home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / smisc.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  43KB  |  1,423 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #include "hdr.h"
  11. #include "vars.h"
  12. #include "setp.h"
  13. #include "dbxp.h"
  14. #include "arithp.h"
  15. #include "chapp.h"
  16. #include "dclmapp.h"
  17. #include "miscp.h"
  18. #include "smiscp.h"
  19.  
  20. /* smisc.c: miscellaneous sem procedures needing semhdr.h */
  21. /* 
  22.  * 23-sep-85    ds
  23.  * add ast_clear to clear defined ast fields before resetting N_KIND.
  24.  *
  25.  * 11-jul-86    ACD
  26.  * modified the DEFINED fields for length clauses.  Previously only
  27.  * N_AST1 was recognized as being defined.  Now, both N_AST1 (the 
  28.  * attribute node) and N_AST2 ( the expression) are recognized
  29.  *
  30.  * 16-apr-85    ds
  31.  * add procedures fordeclared_1 and fordeclared_2. These are used to
  32.  * initialize and advance iteration over declared maps, and are 
  33.  * introduced to reduce the size of the FORDECLARED macro.
  34.  *
  35.  * 24-dec-84    ds
  36.  * have dcl_put NOT set visibility by default.
  37.  *
  38.  * 07-nov-84    ds
  39.  * have node_new_noseq set spans info.
  40.  * add spans_copy(new, old) to copy spans information from node old
  41.  * to node new.
  42.  *
  43.  * 04-nov-84    ds
  44.  * move undone() here as undone.c no longer needed.
  45.  *
  46.  * 02-nov-84    ds
  47.  * add attribute_str to return attribute name based on attribute
  48.  * code in N_VAL field of attribute node.
  49.  *
  50.  * 22-oct-84    ds
  51.  * add dcl_put_vis to enter with explicit visibility indication.
  52.  *
  53.  * 12-oct-84    ds
  54.  * merge in procedures formerly in dcl.c
  55.  */
  56.  
  57. static int const_cmp_kind(Const, Const);
  58.  
  59. void ast_clear(Node node)                                    /*;ast_clear*/
  60. {
  61.     int nk = N_KIND(node);
  62.     if (N_AST2_DEFINED(nk)) N_AST2(node) = (Node) 0;
  63.     if (N_AST3_DEFINED(nk)) N_AST3(node) = (Node) 0;
  64.     if (N_AST4_DEFINED(nk)) N_AST4(node) = (Node) 0;
  65. }
  66.  
  67. Const const_new(int k)                                        /*;const_new*/
  68. {
  69.     Const    result;
  70.  
  71.     result = (Const) smalloc(sizeof(Const_s));
  72.     result->const_kind = k;
  73.     result->const_value.const_int = 0; /* reasonable default value */
  74.     return result;
  75. }
  76.  
  77. Const int_const(int x)                                    /*;int_const*/
  78. {
  79.     Const    result;
  80.  
  81.     result = const_new(CONST_INT);
  82.     result->const_value.const_int = x;
  83.     return result;
  84. }
  85.  
  86. Const fixed_const(long x)                                /*;fixed_const*/
  87. {
  88.     Const    result;
  89.     result = const_new(CONST_FIXED);
  90.     result->const_value.const_fixed = x;
  91.     return result;
  92. }
  93.  
  94. Const uint_const(int *x)                                /*;uint_const*/
  95. {
  96.     Const    result;
  97.  
  98.     if (x == (int *)0) result = const_new(CONST_OM);
  99.     else {
  100.         result = const_new(CONST_UINT);
  101.         result->const_value.const_uint = x;
  102.     }
  103.     return result;
  104. }
  105.  
  106. Const real_const(double x)                                /*;real_const*/
  107. {
  108.     Const    result;
  109.  
  110.     result = const_new(CONST_REAL);
  111.     result->const_value.const_real = x;
  112.     return result;
  113. }
  114.  
  115. Const rat_const(Rational x)                                /*;rat_const*/
  116. {
  117.     Const    result;
  118.  
  119.     if (x == (Rational)0) result =  const_new(CONST_OM);
  120.     else {
  121.         result = const_new(CONST_RAT);
  122.         result->const_value.const_rat = x;
  123.     }
  124.     return result;
  125. }
  126.  
  127. /* Comparison functions for ivalues (Const's) */
  128.  
  129. int const_eq(Const const1, Const const2)                /*;const_eq*/
  130. {
  131.     /* checks to see if 2 Consts have the same value */
  132.  
  133.     switch (const_cmp_kind(const1, const2)) {
  134.     case CONST_OM:
  135.     case CONST_CONSTRAINT_ERROR:
  136.         return TRUE;
  137.     case CONST_INT:
  138.         return (INTV(const1) == INTV(const2));
  139.     case CONST_FIXED:
  140.         return (FIXEDV(const1) == FIXEDV(const2));
  141.     case CONST_UINT:
  142.         return int_eql(UINTV(const1), UINTV(const2));
  143.     case CONST_REAL:
  144.         return (RATV(const1) == RATV(const2));
  145.     case CONST_RAT:
  146.         return rat_eql(RATV(const1), RATV(const2));
  147.     case CONST_STR:
  148.         return streq(const1->const_value.const_str,
  149.           const2->const_value.const_str);
  150.     default:
  151.         return const_cmp_undef(const1, const2);
  152.     }
  153. }
  154.  
  155. int const_ne(Const cleft, Const cright)                        /*;const_ne*/
  156. {
  157.     return !const_eq(cleft, cright);
  158. }
  159.  
  160. int const_lt(Const cleft, Const cright)                        /*;const_lt*/
  161. {
  162.     switch (const_cmp_kind(cleft, cright)) {
  163.     case CONST_INT :
  164.         return (INTV(cleft)<INTV(cright));
  165.     case CONST_UINT :
  166.         return int_lss(UINTV(cleft), UINTV(cright));
  167.     case CONST_FIXED :
  168.         return (FIXEDV(cleft)<FIXEDV(cright));
  169.     case CONST_RAT :
  170.         return rat_lss(RATV(cleft), RATV(cright));
  171.     case CONST_REAL :
  172.         return  REALV(cleft) < REALV(cright);
  173.     default :
  174.         const_cmp_undef(cleft, cright);
  175.         return 0;
  176.     }
  177. }
  178.  
  179. int const_le(Const cleft, Const cright)                        /*;const_le*/
  180. {
  181.     return (const_eq(cleft, cright) || const_lt(cleft, cright));
  182. }
  183.  
  184. int const_gt(Const cleft, Const cright)                        /*;const_gt*/
  185. {
  186.     return const_lt(cright, cleft);
  187. }
  188.  
  189. int const_ge(Const cleft, Const cright)                        /*;const_ge*/
  190. {
  191.     return const_eq(cleft, cright) || const_lt(cright, cleft);
  192. }
  193.  
  194. static int const_cmp_kind(Const cleft, Const cright)        /*;const_cmp_kind*/
  195. {
  196.     int        ckind;
  197.  
  198.     ckind = cleft->const_kind;
  199.     if (ckind == CONST_OM) chaos("const comparison left operand not defined");
  200.     if (ckind != cright->const_kind) {
  201. #ifdef DEBUG
  202.         zpcon(cleft); 
  203.         zpcon(cright);
  204. #endif
  205.         chaos("const comparison operands differing kinds");
  206.     }
  207.     return ckind;
  208. }
  209.  
  210. int const_same_kind(Const cleft, Const cright)            /*;const_same_kind*/
  211. {
  212.     /* returns boolean value indicating whether two Consts are of same kind */
  213.     return (cleft->const_kind == cright->const_kind);
  214. }
  215.  
  216. int const_cmp_undef(Const cleft, Const cright)        /*;const_cmp_undef*/
  217. {
  218. #ifdef DEBUG
  219.     zpcon(cleft); 
  220.     zpcon(cright);
  221. #endif
  222.     chaos("const comparison not defined for these constant types");
  223.     return 0; /* for sake of lint */
  224. }
  225.  
  226. int fx_mantissa(Rational lbd, Rational ubd, Rational small)        /*;mantissa*/
  227. {
  228.     Rational exact_val;
  229.     int *vnum, *vden, *int_1;
  230.     int     power;
  231.  
  232.     lbd = rat_abs(lbd);
  233.     ubd = rat_abs(ubd);
  234.  
  235.     /*  find the exact # of values to be represented (aside from 0) */
  236.  
  237.     if (rat_gtr(lbd, ubd))
  238.         exact_val = rat_div(lbd, small);
  239.     else
  240.         exact_val = rat_div(ubd, small);
  241.     vnum = num(exact_val);
  242.     vden = den(exact_val);
  243.     int_1 = int_fri(1);
  244.  
  245.     /* the mantissa is calculated assuming that the bound is 'small away
  246.      * from a model number, so we subtract one before computing no. of bits
  247.      */
  248.  
  249.     vnum = int_sub(vnum, int_1);
  250.     vnum = int_quo(vnum, vden);
  251.     vden = int_fri(1);
  252.     power = 1;
  253.     while (int_gtr(vnum, vden)) {
  254.         power++;
  255.         vden = int_add(int_add(vden, vden), int_1);
  256.     }
  257.     return power;
  258. }
  259.  
  260. /* Not used */
  261. void node_free(Node node)                                    /*;node_free*/
  262. {
  263.     /* free nodeentry. Since state of allocated fields not clear
  264.      * only free the node block itself
  265.      */
  266.     chaos("node free");
  267.     if (node != (Node)0) efreet((char *) node, "node-free");
  268. }
  269.  
  270. void to_errfile(char *txt)                                    /*;to_errfile */
  271. {
  272.     printf("%s\n", txt);
  273. }
  274.  
  275. int needs_body(Symbol name)  /*;needs_body*/    
  276. {
  277.     /* Procedures and function specs need bodies of course. So do package
  278.      * specs that contain objects which need bodies.
  279.      */
  280.  
  281.     Symbol    obj;
  282.     char    *id;
  283.     Fordeclared    fd1;
  284.     int    nat;
  285.  
  286.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  needs_body");
  287.  
  288.     nat = NATURE(name);
  289.     if (nat == na_package_spec || nat == na_generic_package_spec) {
  290.         FORDECLARED(id, obj, DECLARED(name), fd1);
  291.             if (IS_VISIBLE(fd1) && obj->scope_of == name
  292.               && needs_body(obj)) return TRUE;
  293.         ENDFORDECLARED(fd1);
  294.         FORDECLARED(id, obj, DECLARED(name), fd1)
  295.             if (TYPE_OF(obj) == symbol_incomplete) return TRUE;
  296.         ENDFORDECLARED(fd1);
  297.         return FALSE;
  298.     }
  299.     if (nat == na_procedure_spec || nat == na_function_spec 
  300.       || nat == na_task_type_spec || nat == na_task_obj_spec
  301.       || nat == na_generic_procedure_spec || nat == na_generic_function_spec)
  302.         return TRUE;
  303.     return FALSE;
  304. }
  305.  
  306. /* The text of kind_str that follows is generated by a spitbol program
  307.  * called AS
  308.  */
  309. char *kind_str(unsigned int as)        /*;kind_str*/
  310. {
  311.     static char *as_names[] = {
  312.         "pragma",
  313.         "arg",
  314.         "obj_decl",
  315.         "const_decl",
  316.         "num_decl",
  317.         "type_decl",
  318.         "subtype_decl",
  319.         "subtype_indic",
  320.         "derived_type",
  321.         "range",
  322.         "range_attribute",
  323.         "constraint",
  324.         "enum",
  325.         "int_type",
  326.         "float_type",
  327.         "fixed_type",
  328.         "digits",
  329.         "delta",
  330.         "array_type",
  331.         "box",
  332.         "subtype",
  333.         "record",
  334.         "component_list",
  335.         "field",
  336.         "discr_spec",
  337.         "variant_decl",
  338.         "variant_choices",
  339.         "string",
  340.         "simple_choice",
  341.         "range_choice",
  342.         "choice_unresolved",
  343.         "others_choice",
  344.         "access_type",
  345.         "incomplete_decl",
  346.         "declarations",
  347.         "labels",
  348.         "character_literal",
  349.         "simple_name",
  350.         "call_unresolved",
  351.         "selector",
  352.         "all",
  353.         "attribute",
  354.         "aggregate",
  355.         "parenthesis",
  356.         "choice_list",
  357.         "op",
  358.         "in",
  359.         "notin",
  360.         "un_op",
  361.         "int_literal",
  362.         "real_literal",
  363.         "string_literal",
  364.         "null",
  365.         "name",
  366.         "qualify",
  367.         "new_init",
  368.         "new",
  369.         "statements",
  370.         "statement",
  371.         "null_s",
  372.         "assignment",
  373.         "if",
  374.         "cond_statements",
  375.         "condition",
  376.         "case",
  377.         "case_statements",
  378.         "loop",
  379.         "while",
  380.         "for",
  381.         "forrev",
  382.         "block",
  383.         "exit",
  384.         "return",
  385.         "goto",
  386.         "subprogram_decl",
  387.         "procedure",
  388.         "function",
  389.         "operator",
  390.         "formal",
  391.         "mode",
  392.         "subprogram",
  393.         "call",
  394.         "package_spec",
  395.         "package_body",
  396.         "private_decl",
  397.         "use",
  398.         "rename_obj",
  399.         "rename_ex",
  400.         "rename_pack",
  401.         "rename_sub",
  402.         "task_spec",
  403.         "task_type_spec",
  404.         "task",
  405.         "entry",
  406.         "entry_family",
  407.         "accept",
  408.         "delay",
  409.         "selective_wait",
  410.         "guard",
  411.         "accept_alt",
  412.         "delay_alt",
  413.         "terminate_alt",
  414.         "conditional_entry_call",
  415.         "timed_entry_call",
  416.         "abort",
  417.         "unit",
  418.         "with_use_list",
  419.         "with",
  420.         "subprogram_stub",
  421.         "package_stub",
  422.         "task_stub",
  423.         "separate",
  424.         "exception",
  425.         "except_decl",
  426.         "handler",
  427.         "others",
  428.         "raise",
  429.         "generic_function",
  430.         "generic_procedure",
  431.         "generic_package",
  432.         "generic_formals",
  433.         "generic_obj",
  434.         "generic_type",
  435.         "gen_priv_type",
  436.         "generic_subp",
  437.         "generic",
  438.         "package_instance",
  439.         "function_instance",
  440.         "procedure_instance",
  441.         "instance",
  442.         "length_clause",
  443.         "enum_rep_clause",
  444.         "rec_rep_clause",
  445.         "compon_clause",
  446.         "address_clause",
  447.         "any_op",
  448.         "opt",
  449.         "list",
  450.         "range_expression",
  451.         "arg_assoc_list",
  452.         "private",
  453.         "limited_private",
  454.         "code",
  455.         "line_no",
  456.         "index",
  457.         "slice",
  458.         "number",
  459.         "convert",
  460.         "entry_name",
  461.         "array_aggregate",
  462.         "record_aggregate",
  463.         "ecall",
  464.         "call_or_index",
  465.         "ivalue",
  466.         "qual_range",
  467.         "qual_index",
  468.         "qual_discr",
  469.         "qual_arange",
  470.         "qual_alength",
  471.         "qual_adiscr",
  472.         "qual_aindex",
  473.         "check_bounds",
  474.         "discr_ref",
  475.         "row",
  476.         "current_task",
  477.         "check_discr",
  478.         "end",
  479.         "terminate",
  480.         "exception_accept",
  481.         "test_exception",
  482.         "create_task",
  483.         "predef",
  484.         "deleted",
  485.         "insert",
  486.         "arg_convert",
  487.         "end_activation",
  488.         "activate_spec",
  489.         "delayed_type",
  490.         "qual_sub",
  491.         "static_comp",
  492.         "array_ivalue",
  493.         "record_ivalue",
  494.         "expanded",
  495.         "choices",
  496.         "init_call",
  497.         "type_and_value",
  498.         "discard",
  499.         "unread",
  500.         "string_ivalue",
  501.         "instance_tuple",
  502.         "entry_family_name",
  503.         "astend",
  504.         "astnull",
  505.         "aggregate_list",
  506.         "interfaced",
  507.         "record_choice",
  508.         "subprogram_decl_tr",
  509.         "subprogram_tr",
  510.         "subprogram_stub_tr",
  511.         "rename_sub_tr",
  512.         0    };
  513.     return (as <= 199) ? as_names[as] : "INVALID";
  514. }
  515.  
  516. /* following nature_str generated from spitbol program NA (on acf2) */
  517. char *nature_str(int na)                                /*;nature_str*/
  518. {
  519.     static char *na_names[] = {
  520.         "op",
  521.         "un_op",
  522.         "attribute",
  523.         "obj",
  524.         "constant",
  525.         "type",
  526.         "subtype",
  527.         "array",
  528.         "record",
  529.         "enum",
  530.         "literal",
  531.         "access",
  532.         "aggregate",
  533.         "block",
  534.         "procedure_spec",
  535.         "function_spec",
  536.         "procedure",
  537.         "function",
  538.         "in",
  539.         "inout",
  540.         "out",
  541.         "package_spec",
  542.         "package",
  543.         "task_type",
  544.         "task_type_spec",
  545.         "task_obj",
  546.         "task_obj_spec",
  547.         "entry",
  548.         "entry_family",
  549.         "entry_former",
  550.         "generic_procedure_spec",
  551.         "generic_function_spec",
  552.         "generic_package_spec",
  553.         "generic_procedure",
  554.         "generic_function",
  555.         "generic_package",
  556.         "exception",
  557.         "private_part",
  558.         "void",
  559.         "null",
  560.         "discriminant",
  561.         "field",
  562.         "label",
  563.         "generic_part",
  564.         "subprog",
  565.         "body",
  566.         "task",
  567.         "task_body",
  568.         0    };
  569.     return (na > 0 && na <= 48) ? na_names[na-1] : "INVALID";
  570. }
  571.  
  572. int in_open_scopes(Symbol s)                            /*;in_open_scopes*/
  573. {
  574.     return tup_mem((char *) s, open_scopes);
  575. }
  576.  
  577. char *newat_str()                                            /*newat_str*/
  578. {
  579.     static int n = 0;
  580.     char    *s;
  581.  
  582.     n += 1;
  583. #if GWDEAD
  584.     /*   Code changed by GW, to allow seperate compilation */
  585.     s = smalloc(6);
  586.     sprintf(s, "n%04d", n);
  587. #endif
  588.     s = smalloc(8);
  589.     sprintf(s, "n%s%04d", AISFILENAME,n);
  590.     return s;
  591. }
  592.  
  593. char *str_newat()                                            /*;str_newat*/
  594. {
  595.     return newat_str();
  596. }
  597.  
  598. void symtab_copy(Symbol news, Symbol old)                        /*symtab_copy*/
  599. {
  600.     /* Note that this must be changed if symbol table layout changed */
  601.     /* called from ch3 */
  602.  
  603.     int nseq, nunit;
  604.  
  605.     nunit = S_UNIT(news);
  606.     nseq = S_SEQ(news);
  607.     sym_copy(news, old);
  608.     S_SEQ(news) = nseq;
  609.     S_UNIT(news) = nunit;
  610. }
  611.  
  612. void sym_copy(Symbol news, Symbol old)                        /*;sym_copy*/
  613. {
  614.     /* Note that this must be changed if symbol table layout changed */
  615.  
  616.     char    *op, *np;
  617.     int i, n;
  618.  
  619.     n = sizeof(Symbol_s);
  620.     op = (char *)old; 
  621.     np = (char *) news;
  622.     for (i = 1;i <= n;i++) *np++ = *op++;
  623. }
  624.  
  625. void SYMBTABcopy(Symbol news, Symbol old)                    /*SYMBATBcopy */
  626. {
  627.     /* copy symbol table fields referenced by (Setl) SYMBTAB macro, i.e.,
  628.      *    NATURE, TYPE_OF, SIGNATURE and OVERLOADS
  629.      * copies only pointers and not the structures pointed to by these pointers.
  630.      * thus, it may not be correct in the general case !
  631.      */
  632.  
  633.     NATURE(news) = NATURE(old);
  634.     TYPE_OF(news) = TYPE_OF(old);
  635.     SIGNATURE(news) = SIGNATURE(old);
  636.     OVERLOADS(news) = OVERLOADS(old);
  637.     /* what about a set_copy ?? */
  638. }
  639.  
  640. Symbol sym_new_noseq(int na)                            /*;sym_new_noseq*/
  641. {
  642.     /* allocate new symbol table entry, nature na */
  643.  
  644.     Symbol sym;
  645.  
  646.     sym = (Symbol) smalloc(sizeof(Symbol_s));
  647.     NATURE(sym) = na;
  648.     /* following not needed since allocate initially as zeros 
  649.      * ORIG_NAME(sym) = (char *)0;
  650.      * S_SEQ(sym) = 0; 
  651.      * S_UNIT(sym) = 0;
  652.      */
  653.     /* set SEGMENT to -1 to indicate not yet defined */
  654.     S_SEGMENT(sym) = -1;
  655.     return sym;
  656. }
  657.  
  658. Symbol sym_new(int na)                                        /*;sym_new*/
  659. {
  660.     /* allocate new symbol table entry, nature na.
  661.      * Increment sequence number and enter as sequence field of new entry 
  662.      *
  663.      */
  664.  
  665.     Symbol sym;
  666.  
  667.     sym = sym_new_noseq(na);
  668.     if (seq_symbol_n > (int) seq_symbol[0])
  669.          chaos("sym_new seq_symbol_n exceeds allocated length");
  670.     if (seq_symbol_n == (int)seq_symbol[0]) {
  671.         seq_symbol = tup_exp(seq_symbol,
  672.           (unsigned) (seq_symbol_n + SEQ_SYMBOL_INC));
  673.     }
  674.     seq_symbol_n += 1;
  675.     seq_symbol[seq_symbol_n] = (char *) sym;
  676.     S_SEQ(sym) = seq_symbol_n;
  677.     S_UNIT(sym) = unit_number_now; /* added by ds  2 dec 84*/
  678. #ifdef DEBUG
  679.     if (trapss>0 && S_SEQ(sym) == trapss && S_UNIT(sym) == trapsu) traps(sym);
  680. #endif
  681.     return sym;
  682. }
  683.  
  684. /* Not Used */
  685. int sym_free(Symbol sym)                                    /*;sym_free*/
  686. {
  687.     /* free symbol entry. Since state of allocated fields not clear
  688.      * only free the symbol block itself
  689.      */
  690.     return 0; /* do not free, use smalloc to allocate instead */
  691. #ifdef SKIP
  692.     if (sym != (Symbol)0) efreet((char *) sym, "sym-free");
  693. #endif
  694. }
  695.  
  696. /* procedures for private_declarations */
  697. Private_declarations private_decls_new(int n)        /*;private_decls_new*/
  698. {
  699.     Private_declarations    ps;
  700.     Tuple    t;
  701.  
  702.     ps = (Private_declarations) emalloct(sizeof(Private_declarations_s),
  703.       "private-declarations");
  704.     t = tup_new(n*2);
  705.     ps->private_declarations_tuple = t;
  706.     return ps;
  707. }
  708.  
  709. Symbol private_decls_get(Private_declarations pdecl, Symbol s)
  710.                                                     /*;private_decls_get*/
  711. {
  712.     Forprivate_decls    fp;
  713.     Symbol    s1, s2;
  714.  
  715.     if (s == (Symbol)0) return (Symbol)0;
  716.     FORPRIVATE_DECLS(s1, s2, pdecl, fp);
  717.         if (s1 == s) return s2;
  718.     ENDFORPRIVATE_DECLS(fp);
  719.     return    (Symbol)0;
  720. }
  721.  
  722. void private_decls_put(Private_declarations pdecl, Symbol s1)
  723.                                                     /*;private_decls_put*/
  724. {
  725.     int    i, n, newi = FALSE;
  726.     Tuple    t;
  727.     Symbol    s2;
  728.     Set    ovl;
  729.  
  730.     t = pdecl->private_declarations_tuple;
  731.     n = tup_size(t);
  732.     s2 = (Symbol)0;
  733.     for (i = 1;i <= n;i += 2) {
  734.         if (t[i] == (char *)s1) {
  735.             s2 = (Symbol) t[i+1]; /* if entry exists */
  736.             break;
  737.         }
  738.     }
  739.     if (s2 == (Symbol)0) { /* if need new entry */
  740.         newi = TRUE;
  741.         t = tup_exp(t, (unsigned) n+2);
  742.         pdecl->private_declarations_tuple = t;
  743.         t[n+1] = (char *)s1;
  744.         s2 = sym_new(NATURE(s1));
  745.         t[n+2] = (char *)s2;
  746.         /* TBSL: we need to copy signature and overloads when entering
  747.          * symbols with nature na_constant and na_type as these can have
  748.          * different representations in the private and public parts.
  749.          * ds 5-dec-84
  750.          */
  751.     }
  752.     /* if new entry, need to copy overloads (will always be a set) */
  753.     if (newi) {
  754.         /* now copy current information from s1 to s2 */
  755.         symtab_copy(s2, s1);
  756.         ovl = OVERLOADS(s1);
  757.         if (ovl != (Set)0)
  758.             OVERLOADS(s2) = set_copy(ovl);
  759.         /* also need to copy signature if private type */
  760.         if(TYPE_OF(s1) == symbol_private
  761.           || TYPE_OF(s1) == symbol_limited_private) {
  762.             if (SIGNATURE(s1) != (Tuple)0) {
  763.                 SIGNATURE(s2) = tup_copy(SIGNATURE(s1));
  764.                 if (declared_components(s2) != (Tuple) 0)
  765.                     SIGNATURE(s2)[4] =
  766.                       (char *) dcl_copy((Declaredmap)declared_components(s1));
  767.             }
  768.         }
  769.     }
  770. }
  771.  
  772. void private_decls_swap(Symbol s1, Symbol s2)        /*;private_decls_swap*/
  773. {
  774.     /* swap symbol table entries for s1 and s2 */
  775.  
  776.     struct Symbol_s tmp;
  777.     struct Symbol_s        *sp;
  778.     int        i, n, seq1, unit1, seq2, unit2;
  779.     char    *p1, *p2;
  780.  
  781.     /* this version assumes all symbol table entries of the same size */
  782.     p1 = (char *)s1;
  783.     sp = &tmp;
  784.     n = sizeof(Symbol_s);
  785.     /* copy s1 to tmp */
  786.     seq1 = S_SEQ(s1); 
  787.     unit1 = S_UNIT(s1);
  788.     seq2 = S_SEQ(s2); 
  789.     unit2 = S_UNIT(s2);
  790.     p1 = (char *)sp; 
  791.     p2 = (char *)s1;
  792.     for (i = 0;i<n;i++) *p1++ = *p2++;
  793.     /* copy s2 to s1 */
  794.     p1 = (char *)s1; 
  795.     p2 = (char *)s2;
  796.     for (i = 0;i<n;i++) *p1++ = *p2++;
  797.     /* copy tmp to s2 */
  798.     p1 = (char *)sp; 
  799.     p2 = (char *)s2;
  800.     for (i = 0;i<n;i++) *p2++ = *p1++;
  801.     /* restore original sequence numbers and units */
  802.     S_SEQ(s1) = seq1; 
  803.     S_UNIT(s1) = unit1;
  804.     S_SEQ(s2) = seq2; 
  805.     S_UNIT(s2) = unit2;
  806.     if (REPR(s1)==(Tuple)0) {
  807.        FORCED(s1) = FORCED(s2);
  808.        RCINFO(s1) = RCINFO(s2);
  809.        REPR(s1)   = REPR(s2);
  810.     } 
  811.     else if (REPR(s2)==(Tuple)0) {
  812.        FORCED(s2) = FORCED(s1);
  813.        RCINFO(s2) = RCINFO(s1);
  814.        REPR(s2)   = REPR(s1);
  815.     }
  816. }
  817.  
  818. char *attribute_str(int attrnum)                        /*;attribute_str*/
  819. {
  820.     /* convert internal attribute code to attribute string */
  821.  
  822.     static char *attrnames[] = { 
  823.         "ADDRESS", "AFT", "BASE", "CALLABLE",
  824.         "CONSTRAINED", "O_CONSTRAINED", "T_CONSTRAINED", "COUNT", "DELTA",
  825.         "DIGITS", "EMAX", "EPSILON", "FIRST", "O_FIRST", "T_FIRST", "FIRST_BIT",
  826.         "FORE", "IMAGE", "LARGE", "LAST", "O_LAST", "T_LAST", "LAST_BIT",
  827.         "LENGTH", "O_LENGTH", "T_LENGTH", "MACHINE_EMAX", "MACHINE_EMIN", 
  828.         "MACHINE_MANTISSA", "MACHINE_OVERFLOWS", "MACHINE_RADIX",
  829.         "MACHINE_ROUNDS", "MANTISSA", "POS", "POSITION", "PRED", "RANGE",
  830.         "O_RANGE", "T_RANGE", "SAFE_EMAX", "SAFE_LARGE", "SAFE_SMALL",
  831.         "SIZE", "O_SIZE", "T_SIZE", "SMALL", "STORAGE_SIZE", "SUCC", 
  832.         "TERMINATED", "VAL", "VALUE", "WIDTH", "any_attr"    };
  833.     /* i = (int) N_VAL(node);    pass code, not node (gcs) */
  834.  
  835.     if (attrnum > 52) chaos("attribute_str: invalid internal attriubte code");
  836.     return attrnames[attrnum];
  837. }
  838.  
  839. int no_dimensions(Symbol sym)                                /*;no_dimensions*/
  840. {
  841.     /* no_dimensions is macro defined in hdr.c */
  842.  
  843.     Tuple    tup = SIGNATURE(sym);
  844.     return tup_size((Tuple) tup[1]);
  845. }
  846.  
  847. int in_incp_types(Symbol s)                                    /*;in_incp_types*/
  848. {
  849.     return (s == symbol_private || s == symbol_limited_private)
  850.       || (s == symbol_limited) || (s == symbol_incomplete);
  851. }
  852.  
  853. int in_qualifiers(unsigned int kind)                        /*;in_qualifiers*/
  854. {
  855.     return (kind == as_qual_range || kind == as_qual_index
  856.       || kind == as_qual_discr || kind == as_qual_aindex
  857.       || kind == as_qual_adiscr);
  858. }
  859.  
  860. int in_univ_types(Symbol s)                                /*;in_univ_types*/
  861. {
  862.     return s == symbol_universal_real  || s == symbol_universal_integer;
  863. }
  864.  
  865. int in_vis_mods(Symbol v)                                    /*;in_vis_mods*/
  866. {
  867.     /* Test for membership in vis_mods. Assume vis_mods is tuple of symbols */
  868.     return tup_mem((char *) v, vis_mods);
  869. }
  870.  
  871. void undone(char *s)                                                /*;undone*/
  872. {
  873.     chaos(strjoin(s, " not implemented"));
  874. }
  875.  
  876. int is_type(Symbol name)                                         /*;is_type*/
  877. {
  878.     static int type_natures[8] = {
  879.         na_type, na_subtype, na_array, na_record, na_enum, na_access,
  880.         na_task_type, na_task_type_spec    };
  881.     int i;
  882.  
  883.     if (name == (Symbol)0) return FALSE;
  884.     for (i = 0; i < 8; i++)
  885.         if(NATURE(name) == type_natures[i]) return TRUE;
  886.     return FALSE;
  887. }
  888.  
  889. int is_fixed_type(Symbol typ)                                /*;is_fixed_type*/
  890. {
  891.     /* IS_FIXED_TYPE is procedure is_fixed_type() in C:
  892.      *   macro IS_FIXED_TYPE(typ);  (SIGNATURE(typ)(1) = co_delta)  endm;
  893.      */
  894.  
  895.     Tuple    tup;
  896.  
  897.     if (typ == symbol_dfixed) return TRUE;
  898.     tup = SIGNATURE(typ);
  899.     if (tup == (Tuple)0) return FALSE;
  900.     return tup[1] == (char *)CONSTRAINT_DELTA;
  901. }
  902.  
  903. int is_generic_type(Symbol type_mark)                    /*;is_generic_type*/
  904. {
  905.     int attr;
  906.  
  907.     attr = (int) misc_type_attributes(type_mark);
  908.     return    TA_GENERIC & attr;
  909. }
  910.  
  911. int is_access(Symbol name)                                    /*;is_access */
  912. {
  913.     /* TBSL: this appears identical to is_access_type in adagen and should be
  914.      * merged with it
  915.      */
  916.     if (name == (Symbol)0 || root_type(name) == (Symbol) 0)
  917.         return FALSE;
  918.     else return (NATURE((root_type(name))) == na_access);
  919. }
  920.  
  921. int is_scalar_type(Symbol name)                            /*;is_scalar_type*/
  922. {
  923.     Symbol    root;
  924.     Tuple   sig;
  925.  
  926.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  is_scalar_type");
  927.  
  928.     root = root_type(name);
  929.     /* if (root in scalar_types ...)
  930.      * ??const scalar_types =
  931.      *     {'INTEGER', 'FLOAT', '$FIXED', 'universal_integer', 'universal_real',
  932.      *      'universal_fixed', 'discrete_type'};
  933.      */
  934.     if (root == symbol_integer || root == symbol_float || root == symbol_dfixed
  935.       || root == symbol_universal_integer || root == symbol_universal_real
  936.       || root == symbol_universal_fixed || root == symbol_discrete_type )
  937.         return TRUE;
  938.     if (NATURE(root) == na_type) { /* fixed type also scalar */
  939.         sig = SIGNATURE(root);
  940.         if (sig != (Tuple)0 && (int) sig[1] == CONSTRAINT_DELTA) return TRUE;
  941.     }
  942.     return      NATURE(root) == na_enum;
  943. }
  944.  
  945. int is_numeric_type(Symbol typ)                            /*;is_numeric_type */
  946. {
  947.     Symbol root;
  948.  
  949.     root = root_type (typ);
  950.     return (root == symbol_integer || root == symbol_float
  951.       || root == symbol_dfixed || root == symbol_universal_integer
  952.       || root == symbol_universal_fixed || root == symbol_universal_real);
  953. }
  954.  
  955. int is_record(Symbol typ)                                        /*;is_record*/
  956. {
  957.     /* This predicate is used to validate selected component notation and
  958.      * the examination of discriminant lists.
  959.      */
  960.  
  961.     Symbol    r;
  962.  
  963.     if (typ == (Symbol) 0) /* for case when typ = om in setl */
  964.         return FALSE;
  965.     if (NATURE(typ) == na_record) return TRUE;
  966.     if (NATURE(typ) != na_subtype && NATURE(typ) != na_type) return FALSE;
  967.     if (NATURE(base_type(typ)) == na_record) return TRUE;
  968.     r = root_type(typ);
  969.     /* prevent illegal reference to field of a private type */
  970.         if (typ == symbol_private) return FALSE;
  971.     if (in_incp_types(TYPE_OF(r)) && has_discriminants(r)) return TRUE;
  972.     return FALSE;
  973. }
  974.  
  975. int is_anonymous_task(Symbol name)                        /*;is_anonymous_task*/
  976. {
  977.     /* see if task anonymous (corresponds to macro of same name in SETL vern)*/
  978.     /* Procedure task_spec (9) in SETL uses special prefix to flag anonymous
  979.      * tasks. We simplify that to making the first character a colon 
  980.      */
  981.  
  982.     char    *s;
  983.     int        n;
  984.  
  985.     if (!is_task_type(name)) return FALSE;
  986.     s = ORIG_NAME(name);
  987.     if (s == (char *)0 ) return FALSE;
  988.     s = substr(s, 1, 10);
  989.     if (s == (char *)0) return FALSE;
  990.     n = streq(s, "task_type:");
  991. #ifndef SMALLOC
  992.     efreet(s, "is-anonymous-task"); /* free temporary substring*/
  993. #endif
  994.     return n;
  995. }
  996.  
  997. int is_task_type(Symbol task)                                /*;is_task_type*/
  998. {
  999.     return NATURE(task) == na_task_type || NATURE(task) == na_task_type_spec;
  1000. }
  1001.  
  1002. Node discr_map_get(Tuple dmap, Symbol sym)                /*;discr_map_get*/
  1003. {
  1004.     int        i, n;
  1005.  
  1006.     n = tup_size(dmap);
  1007.     for (i = 1;i <= n; i += 2)
  1008.         if ((Symbol) dmap[i]== sym) return (Node) dmap[i+1];
  1009.     return (Node)0;
  1010. }
  1011.  
  1012. Tuple discr_map_put(Tuple dmap, Symbol sym, Node nod)        /*;discr_map_put*/
  1013. {
  1014.     int        i, n;
  1015.  
  1016.     n = tup_size(dmap);
  1017.     for (i = 1;i <= n; i += 2) {
  1018.         if ((Symbol) dmap[i] == sym) {
  1019.             dmap[i+1] = (char *) nod;
  1020.             return dmap;
  1021.         }
  1022.     }
  1023.     dmap = tup_exp(dmap, (unsigned) n+2);
  1024.     dmap[n+1] = (char *) sym;
  1025.     dmap[n+2] = (char *) nod;
  1026.     return dmap;
  1027. }
  1028.  
  1029. int tup_memsym(Symbol sym, Tuple tp)                        /*;tup_memsym*/
  1030. {
  1031.     /* like tup_mem, but n is symbol, so also check for matching sequence and
  1032.      * unit number
  1033.      */
  1034.  
  1035.     int i;
  1036.     int sz;
  1037.  
  1038.     sz = tup_size(tp);
  1039.     for (i = 1;i <= sz;i++) {
  1040.         if ((Symbol)tp[i] == sym)
  1041.             return TRUE;
  1042.         if (S_SEQ((Symbol)tp[i]) == S_SEQ(sym)
  1043.           && S_UNIT((Symbol)tp[i]) == S_UNIT(sym))
  1044.             return TRUE;
  1045.     }
  1046.     return FALSE;
  1047. }
  1048.  
  1049. void const_check(Const con, int ctyp)                        /*;const_check*/
  1050. {
  1051.     /* check that const has const kind ctyp, raise chaos if not */
  1052.  
  1053.     if (con->const_kind == ctyp) return;
  1054. #ifdef DEBUG
  1055.     fprintf(stderr, "const of kind %d, expect %d\n", con->const_kind, ctyp);
  1056. #endif
  1057.     chaos("const not of expected kind");
  1058. }
  1059.  
  1060. int power_of_2(Const const_arg)                                /*;power_of_2*/
  1061. {
  1062.     /*
  1063.      * DESCR: This procedure finds the closest power of 2 <= the argument.
  1064.      * INPUT: arg:  a rational number.
  1065.      * OUTPUT: [accuracy, power, small]
  1066.      *        accuracy: 'exact' if arg= 2**power, or 'approximate'
  1067.      *                  if arg < 2**power.
  1068.      *        power: integer.
  1069.      *     small: rational value of 2**power
  1070.      * ALGORITHM:
  1071.      *    1- Work only with integers. So if num < den, invert the rational
  1072.      *          and remember.
  1073.      *    2- find first power such that den * 2**power >= num
  1074.      *    3- Adjust and negate if rational was inverted.
  1075.      *  4- Return zero if no errors, or one if cannot convert
  1076.      */
  1077.  
  1078.     Rational arg;
  1079.     int     *d, *n;        /* numerator and denominator of arg */
  1080.     int     inverted;        /* flag TRUE if arg < 1 */
  1081.     int     power;        /* the desired power of two */
  1082.     int    *next_power_of_2;    /* nearest power of 2 to given delta */
  1083.     int     *tmp;
  1084.  
  1085.     arg = RATV(const_arg);
  1086.     n = int_copy(num(arg));
  1087.     d = int_copy(den(arg));
  1088.  
  1089.     if (int_lss(n, d)) {
  1090.         tmp = n;
  1091.         n = d;
  1092.         d = tmp;
  1093.         inverted = TRUE;
  1094.     }
  1095.     else
  1096.         inverted = FALSE;
  1097.  
  1098.     power = 0;
  1099.     next_power_of_2 = int_fri(1);
  1100.     while(power < 127 && int_lss(int_mul(next_power_of_2, d), n)) {
  1101.         /* Should be possible to find  better algorithm.  */
  1102.         next_power_of_2 = int_mul(next_power_of_2, int_fri(2));
  1103.         power++;
  1104.     }
  1105.  
  1106.     if (int_eql(int_mul(next_power_of_2, d), n)) {
  1107.         power_of_2_accuracy = POWER_OF_2_EXACT;
  1108.         if (power == 127) power--;
  1109.         if (inverted) {
  1110.             power_of_2_power = -power;
  1111.             power_of_2_small = rat_fri(int_fri(1), next_power_of_2);
  1112.         }
  1113.         else {
  1114.             power_of_2_power = power;
  1115.             power_of_2_small = rat_fri(next_power_of_2, int_fri(1));
  1116.         }
  1117.     }
  1118.     else {
  1119.         power_of_2_accuracy = POWER_OF_2_APPROXIMATE;
  1120.         if (inverted) {
  1121.             if(power == 127) {
  1122.                 power_of_2_power = 126;
  1123.                 power_of_2_small = rat_fri(next_power_of_2, int_fri(1));
  1124.                 return 1;
  1125.             }
  1126.             power_of_2_power = -power;
  1127.             power_of_2_small = rat_fri(int_fri(1), next_power_of_2);
  1128.         }
  1129.         else {
  1130.             power_of_2_power = power - 1;
  1131.             power_of_2_small = rat_fri(next_power_of_2, int_fri(2));
  1132.         }
  1133.     }
  1134.     return 0;
  1135. }
  1136.  
  1137. Node new_ivalue_node(Const value, Symbol typ)            /*;new_ivalue_node*/
  1138. {
  1139.     /* constructs an ivalue node */
  1140.     Node    node;
  1141.  
  1142.     node         = node_new(as_ivalue);
  1143.     N_VAL (node) = (char *) value;
  1144.     N_TYPE(node) = typ;
  1145.     return node;
  1146. }
  1147.  
  1148. Tuple constraint_new(int ty)                            /*;constraint_new*/
  1149. {
  1150.     Tuple p;
  1151.     /* TBSL: set length correctly, make always five for now */
  1152.     p = tup_new(5);
  1153.     p[1] = (char *) ty;
  1154.  
  1155.     return p;
  1156. }
  1157.  
  1158. union node_list {
  1159.     union node_list *next;
  1160.     Node_s node; };
  1161.  
  1162. static union node_list *head_of_nodes = (union node_list *)0;
  1163.  
  1164. #define NODE_BLOCK_NUMBER 2000
  1165. static Node newBlockOfNodes()
  1166. {
  1167.         int n;
  1168.         union node_list *np = (union node_list *)
  1169.           emalloct(NODE_BLOCK_NUMBER * sizeof(union node_list), "node_group");
  1170.  
  1171.         head_of_nodes = np;
  1172.         for (n = 1; n < NODE_BLOCK_NUMBER; n++) {
  1173.             np->next = np + 1;
  1174.             np++;
  1175.         }
  1176.         np->next = (union node_list *)0;
  1177.         return ((Node)head_of_nodes++);
  1178. }
  1179.  
  1180. Node node_new_noseq(unsigned int na)                    /*;node_new_noseq*/
  1181. {
  1182.     char *np;
  1183.     Node p;
  1184.     int    i;
  1185.  
  1186.     p = (Node)head_of_nodes;
  1187.     if (p)
  1188.         head_of_nodes = head_of_nodes->next;
  1189.     else
  1190.         p = newBlockOfNodes();
  1191.  
  1192.     np = (char *) p;
  1193.     /* clear all fields */
  1194.     for (i = 0; i < sizeof(Node_s); i++) *np++ = 0;
  1195.     N_KIND(p) = na;
  1196.     return p;
  1197. }
  1198.  
  1199. Node node_new(unsigned int na)                                    /*;node_new*/
  1200. {
  1201.     Node p;
  1202.  
  1203.     p = node_new_noseq(na);
  1204.  
  1205.     if (seq_node_n > (int) seq_node[0]) 
  1206.         chaos("node_new seq_node_n exceeds allocated length");
  1207.     /* increment allocated count and assign sequence number for node*/
  1208.     if(seq_node_n == (int) seq_node[0])
  1209.         seq_node = tup_exp(seq_node, (unsigned)  seq_node_n+SEQ_NODE_INC);
  1210.     seq_node_n += 1;
  1211.     seq_node[seq_node_n] = (char *) p;
  1212.     N_SEQ(p) = seq_node_n;
  1213.     N_UNIT(p) = unit_number_now;
  1214. #ifdef DEBUG
  1215.     if (trapns>0 && N_SEQ(p) == trapns && N_UNIT(p) == trapnu) trapn(p);
  1216. #endif
  1217.     /* initialize other fields later */
  1218.     return p;
  1219. }
  1220.  
  1221. int N_DEFINED[] = {
  1222.     N_D_AST1 | N_D_AST2,                        /*   0 pragma */
  1223.     N_D_AST1 | N_D_AST2,                        /*   1 arg */
  1224.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*   2 obj_decl */
  1225.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*   3 const_decl */
  1226.     N_D_AST1 | N_D_AST2,                        /*   4 num_decl */
  1227.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_TYPE,  /*   5 type_decl */
  1228.     N_D_AST1 | N_D_AST2 | N_D_UNQ | N_D_TYPE,   /*   6 subtype_decl */
  1229.     N_D_AST1 | N_D_AST2 | N_D_UNQ,              /*   7 subtype_indic */
  1230.     N_D_AST1,                                   /*   8 derived_type */
  1231.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /*   9 range */
  1232.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_TYPE,  /*  10 range_attribute */
  1233.     N_D_LIST,                                   /*  11 constraint */
  1234.     N_D_LIST,                                   /*  12 enum */
  1235.     N_D_AST1,                                   /*  13 int_type */
  1236.     N_D_AST1,                                   /*  14 float_type */
  1237.     N_D_AST1,                                   /*  15 fixed_type */
  1238.     N_D_AST1 | N_D_AST2,                        /*  16 digits */
  1239.     N_D_AST1 | N_D_AST2,                        /*  17 delta */
  1240.     N_D_AST1 | N_D_AST2 | N_D_UNQ,              /*  18 array_type */
  1241.     N_D_AST1 | N_D_UNQ,                         /*  19 box */
  1242.     N_D_AST1 | N_D_AST2 | N_D_UNQ | N_D_TYPE,   /*  20 subtype */
  1243.     N_D_AST1,                                   /*  21 record */
  1244.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*  22 component_list */
  1245.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*  23 field */
  1246.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*  24 discr_spec */
  1247.     N_D_AST1 | N_D_AST2,                        /*  25 variant_decl */
  1248.     N_D_AST1 | N_D_AST2,                        /*  26 variant_choices */
  1249.     N_D_VAL,                                    /*  27 string */
  1250.     N_D_AST1,                                   /*  28 simple_choice */
  1251.     N_D_AST1,                                   /*  29 range_choice */
  1252.     N_D_AST1,                                   /*  30 choice_unresolved */
  1253.     N_D_AST1 | N_D_AST2,                        /*  31 others_choice */
  1254.     N_D_AST1,                                   /*  32 access_type */
  1255.     N_D_AST1,                                   /*  33 incomplete_decl */
  1256.     N_D_LIST,                                   /*  34 declarations */
  1257.     N_D_LIST,                                   /*  35 labels */
  1258.     N_D_VAL | N_D_TYPE,                         /*  36 character_literal */
  1259.     N_D_VAL | N_D_UNQ | N_D_TYPE,               /*  37 simple_name */
  1260.     N_D_AST1 | N_D_AST2,                        /*  38 call_unresolved */
  1261.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /*  39 selector */
  1262.     N_D_AST1 | N_D_UNQ | N_D_TYPE,              /*  40 all */
  1263.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_TYPE,  /*  41 attribute */
  1264.     N_D_LIST | N_D_TYPE,                        /*  42 aggregate */
  1265.     N_D_AST1 | N_D_TYPE,                        /*  43 parenthesis */
  1266.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /*  44 choice_list */
  1267.     N_D_AST1 | N_D_AST2 | N_D_UNQ | N_D_TYPE,   /*  45 op */
  1268.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /*  46 in */
  1269.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /*  47 notin */
  1270.     N_D_AST1 | N_D_AST2 | N_D_UNQ | N_D_TYPE,   /*  48 un_op */
  1271.     N_D_VAL | N_D_TYPE,                         /*  49 int_literal */
  1272.     N_D_VAL | N_D_TYPE,                         /*  50 real_literal */
  1273.     N_D_VAL | N_D_TYPE,                         /*  51 string_literal */
  1274.     N_D_TYPE,                                   /*  52 null */
  1275.     N_D_AST1 | N_D_UNQ | N_D_TYPE,              /*  53 name */
  1276.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /*  54 qualify */
  1277.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /*  55 new_init */
  1278.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /*  56 new */
  1279.     N_D_AST1 | N_D_AST2,                        /*  57 statements */
  1280.     N_D_AST1 | N_D_AST2,                        /*  58 statement */
  1281.     0,                                          /*  59 null_s */
  1282.     N_D_AST1 | N_D_AST2,                        /*  60 assignment */
  1283.     N_D_AST1 | N_D_AST2,                        /*  61 if */
  1284.     N_D_AST1 | N_D_AST2,                        /*  62 cond_statements */
  1285.     N_D_AST1,                                   /*  63 condition */
  1286.     N_D_AST1 | N_D_AST2,                        /*  64 case */
  1287.     N_D_AST1 | N_D_AST2,                        /*  65 case_statements */
  1288.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*  66 loop */
  1289.     N_D_AST1,                                   /*  67 while */
  1290.     N_D_AST1 | N_D_AST2,                        /*  68 for */
  1291.     N_D_AST1 | N_D_AST2,                        /*  69 forrev */
  1292.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /*  70 block */
  1293.     N_D_AST1 | N_D_AST2 | N_D_UNQ,              /*  71 exit */
  1294.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*  72 return */
  1295.     N_D_AST1,                                   /*  73 goto */
  1296.     N_D_AST1,                                   /*  74 subprogram_decl */
  1297.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*  75 procedure */
  1298.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*  76 function */
  1299.     N_D_VAL | N_D_UNQ | N_D_TYPE,               /*  77 operator */
  1300.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /*  78 formal */
  1301.     N_D_VAL,                                    /*  79 mode */
  1302.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /*  80 subprogram */
  1303.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /*  81 call */
  1304.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*  82 package_spec */
  1305.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /*  83 package_body */
  1306.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*  84 private_decl */
  1307.     N_D_LIST,                                   /*  85 use */
  1308.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /*  86 rename_obj */
  1309.     N_D_AST1 | N_D_AST2,                        /*  87 rename_ex */
  1310.     N_D_AST1 | N_D_AST2,                        /*  88 rename_pack */
  1311.     N_D_AST1 | N_D_AST2,                        /*  89 rename_sub */
  1312.     N_D_AST1 | N_D_AST2 | N_D_UNQ | N_D_TYPE,   /*  90 task_spec */
  1313.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /*  91 task_type_spec */
  1314.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /*  92 task */
  1315.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /*  93 entry */
  1316.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_TYPE,  /*  94 entry_family */
  1317.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /*  95 accept */
  1318.     N_D_AST1,                                   /*  96 delay */
  1319.     N_D_AST1 | N_D_AST2,                        /*  97 selective_wait */
  1320.     N_D_AST1 | N_D_AST2,                        /*  98 guard */
  1321.     N_D_AST1 | N_D_AST2,                        /*  99 accept_alt */
  1322.     N_D_AST1 | N_D_AST2,                        /* 100 delay_alt */
  1323.     N_D_VAL,                                    /* 101 terminate_alt */
  1324.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /* 102 conditional_entry_call */
  1325.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /* 103 timed_entry_call */
  1326.     N_D_LIST,                                   /* 104 abort */
  1327.     N_D_AST1 | N_D_AST2,                        /* 105 unit */
  1328.     N_D_LIST,                                   /* 106 with_use_list */
  1329.     N_D_LIST,                                   /* 107 with */
  1330.     N_D_AST1 | N_D_VAL,                         /* 108 subprogram_stub */
  1331.     N_D_VAL | N_D_UNQ,                          /* 109 package_stub */
  1332.     N_D_VAL | N_D_UNQ,                          /* 110 task_stub */
  1333.     N_D_AST1 | N_D_AST2,                        /* 111 separate */
  1334.     N_D_LIST,                                   /* 112 exception */
  1335.     N_D_LIST,                                   /* 113 except_decl */
  1336.     N_D_AST1 | N_D_AST2,                        /* 114 handler */
  1337.     0,                                          /* 115 others */
  1338.     N_D_AST1 | N_D_TYPE,                        /* 116 raise */
  1339.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /* 117 generic_function */
  1340.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /* 118 generic_procedure */
  1341.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /* 119 generic_package */
  1342.     N_D_LIST,                                   /* 120 generic_formals */
  1343.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /* 121 generic_obj */
  1344.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /* 122 generic_type */
  1345.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /* 123 gen_priv_type */
  1346.     N_D_AST1 | N_D_AST2,                        /* 124 generic_subp */
  1347.     0,                                          /* 125 generic */
  1348.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /* 126 package_instance */
  1349.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /* 127 function_instance */
  1350.     N_D_AST1 | N_D_AST2 | N_D_AST3 | N_D_AST4,  /* 128 procedure_instance */
  1351.     N_D_AST1 | N_D_AST2,                        /* 129 instance */
  1352.     N_D_AST1 | N_D_AST2,                        /* 130 length_clause */
  1353.     N_D_AST1 | N_D_AST2,                        /* 131 enum_rep_clause */
  1354.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /* 132 rec_rep_clause */
  1355.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /* 133 compon_clause */
  1356.     N_D_AST1,                                   /* 134 address_clause */
  1357.     N_D_AST1,                                   /* 135 any_op */
  1358.     0,                                          /* 136 opt */
  1359.     N_D_LIST,                                   /* 137 list */
  1360.     N_D_AST1 | N_D_UNQ,                         /* 138 range_expression */
  1361.     N_D_LIST,                                   /* 139 arg_assoc_list */
  1362.     N_D_AST1,                                   /* 140 private */
  1363.     N_D_AST1,                                   /* 141 limited_private */
  1364.     N_D_AST1,                                   /* 142 code */
  1365.     N_D_VAL,                                    /* 143 line_no */
  1366.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /* 144 index */
  1367.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /* 145 slice */
  1368.     N_D_VAL,                                    /* 146 number */
  1369.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /* 147 convert */
  1370.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /* 148 entry_name */
  1371.     N_D_AST1 | N_D_AST2 | N_D_UNQ | N_D_TYPE,   /* 149 array_aggregate */
  1372.     N_D_AST1 | N_D_AST2 | N_D_UNQ | N_D_TYPE,   /* 150 record_aggregate */
  1373.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /* 151 ecall */
  1374.     N_D_AST1 | N_D_AST2 | N_D_TYPE,             /* 152 call_or_index */
  1375.     N_D_VAL | N_D_TYPE,                         /* 153 ivalue */
  1376.     N_D_AST1 | N_D_TYPE,                        /* 154 qual_range */
  1377.     N_D_AST1 | N_D_UNQ | N_D_TYPE,              /* 155 qual_index */
  1378.     N_D_AST1 | N_D_UNQ | N_D_TYPE,              /* 156 qual_discr */
  1379.     N_D_AST1,                                   /* 157 qual_arange */
  1380.     N_D_AST1,                                   /* 158 qual_alength */
  1381.     N_D_AST1 | N_D_TYPE,                        /* 159 qual_adiscr */
  1382.     N_D_AST1 | N_D_TYPE,                        /* 160 qual_aindex */
  1383.     N_D_AST1 | N_D_AST2,                        /* 161 check_bounds */
  1384.     N_D_AST1 | N_D_UNQ | N_D_TYPE,              /* 162 discr_ref */
  1385.     N_D_AST1 | N_D_UNQ | N_D_TYPE,              /* 163 row */
  1386.     N_D_UNQ,                                    /* 164 current_task */
  1387.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /* 165 check_discr */
  1388.     N_D_AST1,                                   /* 166 end */
  1389.     N_D_AST1 | N_D_VAL,                         /* 167 terminate */
  1390.     N_D_AST1,                                   /* 168 exception_accept */
  1391.     N_D_AST1,                                   /* 169 test_exception */
  1392.     N_D_AST1 | N_D_TYPE,                        /* 170 create_task */
  1393.     N_D_VAL | N_D_UNQ | N_D_TYPE,               /* 171 predef */
  1394.     0,                                          /* 172 deleted */
  1395.     N_D_AST1 | N_D_LIST | N_D_TYPE,             /* 173 insert */
  1396.     N_D_AST1,                                   /* 174 arg_convert */
  1397.     N_D_AST1 | N_D_VAL,                         /* 175 end_activation */
  1398.     N_D_AST1,                                   /* 176 activate_spec */
  1399.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /* 177 delayed_type */
  1400.     N_D_AST1 | N_D_UNQ | N_D_TYPE,              /* 178 qual_sub */
  1401.     N_D_AST1 | N_D_AST2,                        /* 179 static_comp */
  1402.     N_D_AST1 | N_D_AST2,                        /* 180 array_ivalue */
  1403.     N_D_AST1 | N_D_AST2,                        /* 181 record_ivalue */
  1404.     N_D_AST1,                                   /* 182 expanded */
  1405.     N_D_AST1,                                   /* 183 choices */
  1406.     N_D_AST1 | N_D_AST2,                        /* 184 init_call */
  1407.     N_D_AST1 | N_D_AST2,                        /* 185 type_and_value */
  1408.     N_D_AST1,                                   /* 186 discard */
  1409.     N_D_AST1,                                   /* 187 unread */
  1410.     N_D_VAL | N_D_TYPE,                         /* 188 string_ivalue */
  1411.     N_D_VAL,                                    /* 189 instance_tuple */
  1412.     N_D_AST1 | N_D_AST2 | N_D_AST3,             /* 190 entry_family_name */
  1413.     0,                                          /* 191 astend */
  1414.     0,                                          /* 192 astnull */
  1415.     N_D_AST1 | N_D_AST2,                        /* 193 aggregate_list */
  1416.     N_D_AST1 | N_D_UNQ,                         /* 194 interfaced */
  1417.     N_D_AST1 | N_D_AST2,                        /* 195 record_choice */
  1418.     N_D_UNQ,                                    /* 196 subprogram_decl_tr */
  1419.     N_D_AST1 | N_D_AST2 | N_D_UNQ | N_D_AST4,   /* 197 subprogram_tr */
  1420.     N_D_VAL | N_D_UNQ,                          /* 198 subprogram_stub_tr */
  1421.     N_D_AST2 | N_D_UNQ,                         /* 199 rename_sub_tr */
  1422.     0};
  1423.